{-# OPTIONS_GHC -XTemplateHaskell -XDeriveDataTypeable -fglasgow-exts #-}
module WS.Runtime.DeriveXmlable where

import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Data.PackedString
import WS.Runtime.Xmlable
import Data.Typeable
import Data.List
import Text.XML.Light
import Control.Monad
import Control.Arrow

data T1 = T1 deriving (Eq, Typeable)

fromContentN :: forall a. (Xmlable a) => [(String, String)] -> [String] -> Int -> [[Content]] -> a
fromContentN nss ss n cs = fromContent (forFromContent nss ss cs !! n)

{-|
    deriveXmlable works only for types with single constructor and named fields
|-}
deriveXmlable :: Name -> [(String, String)] -> [String] -> Q [Dec]
deriveXmlable t nss ss = do
    TyConI (DataD _ _ _ [RecC name fields] _)  <-  reify t
    ss' <- return (if null ss then map (\(Name ocn _, _, _) -> unpackPS ocn) fields else ss)
    lstTo <- mapM (\(fname, _, _) -> [|toContent . $(varE fname)|]) fields
    lstFrom <- zipWithM (\_ n -> [| fromContentN nss ss' n |]) fields [0..]
    
    d <- [d| 
            instance Xmlable T1 where 
                toContent x = [makeToContent ss' ($(return $ ListE lstTo)) x]
                fromContent cs = $(apps $ return (ConE name) : map (\x -> apps [return x,[|cs|]]) lstFrom)
        |]
    let    [InstanceD [] (AppT xt (ConT _T1)) fs] = d
    return [InstanceD [] (AppT xt (ConT t  )) fs]
    where 
        apps [x] = x
        apps (x:y:zs) = apps ([| $x $y |] : zs)
        apps _ = error "deriveXmlable.apps error"

deriveXmlableDef :: Name -> Q [Dec]
deriveXmlableDef t = deriveXmlable t [] []

fromAttrContentN :: forall a. (Xmlable a) => [(String, String)] -> [String] -> Int -> [([Attr], [Content])] -> a
fromAttrContentN nss ss n cs = fromAttrContent (if n >= length cs then [] else forFromAttrContent nss ss cs !! n)

deriveXmlableAC :: Name -> [(String, String)] -> [String] -> [String] -> Q [Dec]
deriveXmlableAC t nss ssa sse = do
    TyConI (DataD _ _ _ [RecC name fields] _) <- reify t
    ss <- return $ map (\fld@(Name ocn _, _, _) -> (unpackPS ocn, unpackPS ocn `elem` ssa && not (unpackPS ocn `elem` sse) || isAttr fld)) fields
    (ssa', sse') <- return $ map fst *** map fst $ partition snd ss
    [lsta, lste] <- mapM (mapM (\(fname, _, _) -> [|toAttrContent . $(varE fname)|]) . flip filter fields) [isAttr, not . isAttr]
    -- report False $ unlines [show t, "Fields:", show fields, show $ map showIsAttr fields, "Attribs:", show ssa', "Elems:", show sse']
    lst3 <- zipWithM (\_ n -> [| fromAttrContentN nss (map fst ss) n |]) fields [0..]
    
    d <- [d| 
            instance Xmlable T1 where 
                toAttrContent x = [makeToAttrContent ssa' ($(return $ ListE lsta)) sse' ($(return $ ListE lste)) x]
                fromAttrContent cs = $(apps $ return (ConE name) : map (\x -> apps [return x,[|cs|]]) lst3)
        |]
    -- report False $ pprint d
    let    [InstanceD [] (AppT xt (ConT _T1)) fs] = d
    return [InstanceD [] (AppT xt (ConT t  )) fs]
    where 
        apps [x] = x
        apps (x:y:zs) = apps ([| $x $y |] : zs)
        apps _ = error "deriveXmlableAC.apps error"
        showIsAttr (_, _, ConT n) = "ConT (1): " ++ showName n -- ++ " " ++ show nf
        showIsAttr (_, _, AppT (ConT n) (ConT n2)) = "AppT (2): " ++ showName n ++ " "  ++ showName n2
        showIsAttr x = "ShowIsAttr (3): " ++ show x
        isAttr (_, _, ConT n) = "GHC" `isInfixOf` showName n
        isAttr (_, _, AppT (ConT n) (ConT n2)) = showName n == "Data.Maybe.Maybe" && "GHC" `isInfixOf` showName n2
        isAttr _ = False 

deriveXmlableACDef :: Name -> Q [Dec]
-- deriveXmlableACDef = deriveXmlableDef
deriveXmlableACDef t = deriveXmlableAC t [] [] []
